{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Majalan.Base.Event
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Events.
-- 
--------------------------------------------------------------------------------

module Majalan.Base.Event
  ( 

    EventWidth
  , Event
  , zeroEvent
  , makeEvent
  , runEvent
  , displaceEvent
  , askSymbolicDuration
  , compoundEvent

  , EventFw
  , zeroEventFw
  , makeEventFw
  , runEventFw
  , displaceEventFw

  , fixWidth
  , unfixWidth

  , compoundEventFw  -- ? Is there such a thing

  , EventB1
  , EventB2
  , EventB3
  , EventB4
  , EventB5

  , EventFwB1
  , EventFwB2
  , EventFwB3
  , EventFwB4
  , EventFwB5

  )  where

import Majalan.Base.Context
import Majalan.Base.Internal.Base
import Majalan.Base.Internal.IStmt
import Majalan.Base.Internal.Utils
import Majalan.Base.Trail

import Control.Applicative
import qualified Data.Map as M
import Data.Monoid


type EventWidth = Seconds

--------------------------------------------------------------------------------




-- eventi writes answer as impulse:
--
-- > eventi :: Seconds -> Seconds -> Event impl -> EventList uctx impl ()
-- 

data EventAns a = EventAns 
    { evt_ans_stmts     :: !(H IStmt) 
    , evt_ans_tspan     :: !TimeSpan 
    , evt_ans_result    :: !a
    }

-- Events are always supplied with /duration/ at the call site,
-- this is unlike text in PostScript where /width/ implicitly
-- stored in characters. Thus we don\'t return duration from an 
-- Event, because we have told the event the duration in the 
-- first place.




-- Events should support concat. 
-- We want to consider trills an event rather than an evenlist,
-- the same goes for chords, etc.


--
-- Widths and Durations
-- ====================
--
-- For some instruments, duration is the same as width 
-- (ideal width).
-- E.g. idealized synthesizer - plays note whilst key is pressed.
--
-- Some instruments have long decay - e.g. Bowed Bar.
-- The duration passed to Csound is fixed say three seconds, but 
-- the distance between one note and the next (the width) varies.
-- In a score "duration" is width.
-- TimeSpan is independent of score duration.
--
-- Some instruments have rapid attack - rapid decay, e.g. hi-hat.
-- The duration passed to Csound is fixed say a half a seconds, but 
-- the distance between one note and the next (the width) varies.
-- In a score "duration" is width.
-- TimeSpan is independent of score duration.
--
-- Some instruments have both ideal width and fixed width, e.g. 
-- a violin where bowing has ideal width and pizzicato has fixed
-- width.
--



type SymbolicDuration = Seconds

-- Functional params are onset and (metrical) duration

newtype Event uctx a = Event { 
    getEvent :: Ctx uctx -> Onset -> SymbolicDuration -> EventAns a }

type instance UserCtx (Event uctx) = uctx

-- A Functor instance lets us change 
-- @Event uctx a@ to @Event uctx ()@.
--
instance Functor (Event ctx) where
  fmap f ea = Event $ \r ot drn -> 
      let EventAns stmts1 tspan1 a = getEvent ea r ot drn 
      in EventAns stmts1 tspan1 (f a)

-- Applicative, Monad ?
-- We want to allow compound Events (trills, tremolos,...) that
-- have staggered onsets dividing the duration. The obvious way
-- to do this is make Event a monad so we can query duration 
-- (as per a reader) and divide it.

instance Applicative (Event uctx) where
  pure a    = zeroEvent a
  mf <*> ma = Event $ \r ot drn -> 
      let EventAns stmts1 tspan1 f = getEvent mf r ot drn
          EventAns stmts2 tspan2 a = getEvent ma r ot drn
      in EventAns { evt_ans_stmts     = stmts1 `appendH` stmts2
                  , evt_ans_tspan     = tspan1 `unionTimeSpan` tspan2
                  , evt_ans_result    = f a
                  }

instance Monad (Event uctx) where
  return    = pure
  ma >>= k  = Event $ \r ot drn -> 
      let EventAns stmts1 tspan1 a = getEvent ma r ot drn
          EventAns stmts2 tspan2 b = getEvent (k a) r ot drn
      in EventAns { evt_ans_stmts     = stmts1 `appendH` stmts2
                  , evt_ans_tspan     = tspan1 `unionTimeSpan` tspan2
                  , evt_ans_result    = b
                  }

     

instance Monoid a => Monoid (Event uctx a) where
  mempty           = zeroEvent mempty
  ma `mappend` mb  = Event $ \r ot drn -> 
      let EventAns stmts1 tspan1 a = getEvent ma r ot drn
          EventAns stmts2 tspan2 b = getEvent mb r ot drn
      in EventAns { evt_ans_stmts     = stmts1 `appendH` stmts2
                  , evt_ans_tspan     = tspan1 `unionTimeSpan` tspan2
                  , evt_ans_result    = a <> b
                  }
     



zeroEvent :: a -> Event uctx a
zeroEvent ans = Event $ \_ ot drn -> 
    let tspan = TimeSpan ot drn 
    in EventAns { evt_ans_stmts     = emptyH
                , evt_ans_tspan     = tspan
                , evt_ans_result    = ans
                }


-- Should Event have Context - if so then params need to be a function:
--
-- > makeEvent :: CsOrch inst => inst -> a -> (Ctx uctx -> [Value]) -> Event uctx a

makeEvent :: CsOrch inst => inst -> a -> (uctx -> [Value]) -> Event uctx a
makeEvent inst ans paramsf = Event $ \r ot drn -> 
    let tspan = TimeSpan ot drn
        stmt1 = IStmt { inst_num      = instNumber $ inst
                      , istart        = ot
                      , iduration     = drn
                      , ivalues       = paramsf (getUserCtx r)
                      }
    in EventAns { evt_ans_stmts     = wrapH stmt1 
                , evt_ans_tspan     = tspan
                , evt_ans_result    = ans
                }

-- 


runEvent :: Event uctx a -> Ctx uctx -> Onset -> Seconds 
         -> (H IStmt, TimeSpan, a)
runEvent ma ctx ot drn = 
    let EventAns hs ts a = getEvent ma ctx ot drn in (hs,ts,a)



displaceEvent:: Seconds -> Event uctx a -> Event uctx  a
displaceEvent d ma = Event $ \r start drn -> getEvent ma r (start + d) drn


askSymbolicDuration :: Event uctx Seconds
askSymbolicDuration = Event $ \_ start drn -> 
    let tspan = TimeSpan start drn
    in EventAns emptyH tspan drn


compoundEvent :: Monoid a
              => Trail impl -> (impl -> Event uctx a) -> Event uctx a
compoundEvent trl mf = let impls = M.toAscList $ execTrail 0 trl in
    mconcat $ map (\(dt,a) -> displaceEvent dt $ mf a) impls

--------------------------------------------------------------------------------
-- Should Fixed-width Events have a distinct type?

-- Design / naming note 
-- We should prefer suffixes to prefixes...


newtype EventFw uctx a = EventFw { 
    getEventFw :: Ctx uctx -> Onset -> EventAns a }

type instance UserCtx (EventFw uctx) = uctx

instance Functor (EventFw ctx) where
  fmap f ea = EventFw $ \r ot -> 
      let EventAns stmts1 tspan1 a = getEventFw ea r ot 
      in EventAns stmts1 tspan1 (f a)
    
instance Applicative (EventFw uctx) where
  pure a    = zeroEventFw a
  mf <*> ma = EventFw $ \r ot -> 
      let EventAns stmts1 tspan1 f = getEventFw mf r ot
          EventAns stmts2 tspan2 a = getEventFw ma r ot
      in EventAns { evt_ans_stmts     = stmts1 `appendH` stmts2
                  , evt_ans_tspan     = tspan1 `unionTimeSpan` tspan2
                  , evt_ans_result    = f a
                  }

instance Monad (EventFw uctx) where
  return    = pure
  ma >>= k  = EventFw $ \r ot -> 
      let EventAns stmts1 tspan1 a = getEventFw ma r ot
          EventAns stmts2 tspan2 b = getEventFw (k a) r ot
      in EventAns { evt_ans_stmts     = stmts1 `appendH` stmts2
                  , evt_ans_tspan     = tspan1 `unionTimeSpan` tspan2
                  , evt_ans_result    = b
                  }


instance Monoid a => Monoid (EventFw uctx a) where
  mempty           = zeroEventFw mempty
  ma `mappend` mb  = EventFw $ \r ot -> 
      let EventAns stmts1 tspan1 a = getEventFw ma r ot
          EventAns stmts2 tspan2 b = getEventFw mb r ot
      in EventAns { evt_ans_stmts     = stmts1 `appendH` stmts2
                  , evt_ans_tspan     = tspan1 `unionTimeSpan` tspan2
                  , evt_ans_result    = a <> b
                  }
     


zeroEventFw :: a -> EventFw uctx a
zeroEventFw ans = EventFw $ \_ ot -> 
    let tspan = TimeSpan ot 0 
    in EventAns { evt_ans_stmts     = emptyH
                , evt_ans_tspan     = tspan
                , evt_ans_result    = ans
                }


makeEventFw :: CsOrch inst 
            => inst -> a  -> Seconds -> (uctx -> [Value])
            -> EventFw uctx a
makeEventFw inst ans drn paramsf = EventFw $ \r ot -> 
    let tspan = TimeSpan ot drn
        stmt1 = IStmt { inst_num      = instNumber $ inst
                      , istart        = ot
                      , iduration     = drn
                      , ivalues       = paramsf (getUserCtx r)
                      }
    in EventAns { evt_ans_stmts     = wrapH stmt1 
                , evt_ans_tspan     = tspan
                , evt_ans_result    = ans
                }


runEventFw :: EventFw uctx a -> Ctx uctx -> Onset -> (H IStmt, TimeSpan, a)
runEventFw ma ctx ot = 
    let EventAns hs ts a = getEventFw ma ctx ot in (hs,ts,a)


displaceEventFw:: Seconds -> EventFw uctx a -> EventFw uctx  a
displaceEventFw d ma = EventFw $ \r start -> getEventFw ma r (start + d)



unfixWidth :: EventFw uctx a -> Event uctx a
unfixWidth ma = Event $ \r start _ -> 
    getEventFw ma r start

fixWidth :: Seconds -> Event uctx a -> EventFw uctx a
fixWidth drn ma = EventFw $ \r start -> 
    getEvent ma r start drn

-- Note - compound EventFw is not a EventFw (this needs renaming)...
compoundEventFw :: Monoid a
                => Trail impl -> (impl -> EventFw uctx a) -> Event uctx a
compoundEventFw trl mf = let impls = M.toAscList $ execTrail 0 trl in
    mconcat $ map (\(dt,a) -> displaceEvent dt $ unfixWidth $ mf a) impls


--------------------------------------------------------------------------------
-- Time varying events

type EventB1 b1 uctx a              = b1 -> Event uctx a
type EventB2 b1 b2 uctx a           = b1 -> b2 -> Event uctx a
type EventB3 b1 b2 b3 uctx a        = b1 -> b2 -> b3 -> Event uctx a
type EventB4 b1 b2 b3 b4 uctx a     = b1 -> b2 -> b3 -> b4 -> Event uctx a
type EventB5 b1 b2 b3 b4 b5 uctx a  = b1 -> b2 -> b3 -> b4 -> b5 -> Event uctx a

type EventFwB1 b1 uctx a              = b1 -> EventFw uctx a
type EventFwB2 b1 b2 uctx a           = b1 -> b2 -> EventFw uctx a
type EventFwB3 b1 b2 b3 uctx a        = b1 -> b2 -> b3 -> EventFw uctx a
type EventFwB4 b1 b2 b3 b4 uctx a     = b1 -> b2 -> b3 -> b4 -> EventFw uctx a
type EventFwB5 b1 b2 b3 b4 b5 uctx a  = 
    b1 -> b2 -> b3 -> b4 -> b5 -> EventFw uctx a
